home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / kits / gambit / hash.scm < prev    next >
Text File  |  1992-09-23  |  5KB  |  171 lines

  1. ; -*-Scheme-*-
  2. ;
  3. ; $Id: gambit_hash.scm,v 1.2 1992/09/23 15:24:00 birkholz Exp $
  4. ; $MIT-Header: prop1d.scm,v 14.4 89/09/15 17:16:35 GMT jinx Exp $
  5. ;
  6. ; Copyright (c) 1988, 1989 Massachusetts Institute of Technology
  7. ;
  8. ; This material was developed by the Scheme project at the Massachusetts
  9. ; Institute of Technology, Department of Electrical Engineering and
  10. ; Computer Science.  Permission to copy this software, to redistribute
  11. ; it, and to use it for any purpose is granted, subject to the following
  12. ; restrictions and understandings.
  13. ;
  14. ; 1. Any copy made of this software must include this copyright notice
  15. ; in full.
  16. ;
  17. ; 2. Users of this software agree to make their best efforts (a) to
  18. ; return to the MIT Scheme project any improvements or extensions that
  19. ; they make, so that these may be included in future releases; and (b)
  20. ; to inform MIT of noteworthy uses of this software.
  21. ; 3. All materials developed as a consequence of the use of this
  22. ; software shall duly acknowledge such use, in accordance with the usual
  23. ; standards of acknowledging credit in academic research.
  24. ;
  25. ; 4. MIT has made no warrantee or representation that the operation of
  26. ; this software will be error-free, and MIT is under no obligation to
  27. ; provide any services, by way of maintenance, update, or otherwise.
  28. ;
  29. ; 5. In conjunction with products arising from the use of this material,
  30. ; there shall be no use of the name of the Massachusetts Institute of
  31. ; Technology nor of any adaptation thereof in any advertising,
  32. ; promotional, or sales literature without prior written consent from
  33. ; MIT in each case.
  34.  
  35. ; This file requires the following non-IEEE primitives:
  36.  
  37. ; ##weak-cons, ##weak-car, ##weak-cdr, ##weak-set-cdr! for manipulating
  38. ; "weak-cons cells," whose cdr is normal but whose car turns to #F
  39. ; during a garbage collection if no non-weak references are found to
  40. ; the object in the car.
  41.  
  42. ; ##gc-finalize registers a thunk (procedure of no arguments) to be called
  43. ; after each garbage collection is complete and before Scheme resumes
  44. ; running.
  45.  
  46. ;;;; One Dimensional Property Tables
  47.  
  48. (define (initialize-oned-table-package!)
  49.   (set! population-of-oned-tables (make-population)))
  50.  
  51. (define population-of-oned-tables #f)
  52.  
  53. (define (gc-oned-tables!)
  54.   (map-over-population! population-of-oned-tables oned-table/clean!))
  55.  
  56. (define (make-oned-table)
  57.   (let ((table (list oned-table-tag)))
  58.     (add-to-population! population-of-oned-tables table)
  59.     table))
  60.  
  61. (define (oned-table? object)
  62.   (and (pair? object)
  63.        (eq? (car object) oned-table-tag)))
  64.  
  65. (define oned-table-tag
  66.   "1D table")
  67.  
  68. (define false-key
  69.   "false key")
  70.  
  71. (define (weak-assq key table)
  72.   (let loop ((previous table) (alist (cdr table)))
  73.     (and (not (null? alist))
  74.      (let ((entry (car alist))
  75.            (next (cdr alist)))
  76.        (let ((key* (##weak-car entry)))
  77.          (cond ((not key*)
  78.             (set-cdr! previous next)
  79.             (loop previous next))
  80.            ((eq? key* key)
  81.             entry)
  82.            (else
  83.             (loop alist next))))))))
  84.  
  85. (define (oned-table/get table key default)
  86.   (let ((entry (weak-assq (or key false-key) table)))
  87.     (if entry
  88.     (##weak-cdr entry)
  89.     default)))
  90.  
  91. (define (oned-table/lookup table key if-found if-not-found)
  92.   (let ((entry (weak-assq (or key false-key) table)))
  93.     (if entry
  94.     (if-found (##weak-cdr entry))
  95.     (if-not-found))))
  96.  
  97. (define (oned-table/put! table key value)
  98.   (let ((key (or key false-key)))
  99.     (let ((entry (weak-assq key table)))
  100.       (if entry
  101.       (##weak-set-cdr! entry value)
  102.       (set-cdr! table
  103.             (cons (##weak-cons key value)
  104.               (cdr table))))
  105.       #f)))
  106.  
  107. (define (oned-table/remove! table key)
  108.   (let ((key (or key false-key)))
  109.     (let loop ((previous table) (alist (cdr table)))
  110.       (if (not (null? alist))
  111.       (let ((key* (##weak-car (car alist)))
  112.         (next (cdr alist)))
  113.         (loop (if (or (not key*) (eq? key* key))
  114.               ;; Might as well clean whole list.
  115.               (begin
  116.             (set-cdr! previous next)
  117.             previous)
  118.               alist)
  119.           next))))))
  120.  
  121. (define (oned-table/clean! table)
  122.   (let loop ((previous table) (alist (cdr table)))
  123.     (if (not (null? alist))
  124.     (let ((next (cdr alist)))
  125.       (loop (if (##weak-car (car alist))
  126.             alist
  127.             (begin
  128.               (set-cdr! previous next)
  129.               previous))
  130.         next)))))
  131.  
  132. (define (oned-table/alist table)
  133.   (let loop ((previous table) (alist (cdr table)) (result '()))
  134.     (if (null? alist)
  135.     result
  136.     (let ((entry (car alist))
  137.           (next (cdr alist)))
  138.       (let ((key (##weak-car entry)))
  139.         (if (not key)
  140.         (begin
  141.           (set-cdr! previous next)
  142.           (loop previous next result))
  143.         (loop alist
  144.               next
  145.               (cons (cons (and (not (eq? key false-key)) key)
  146.                   (##weak-cdr entry))
  147.                 result))))))))
  148.  
  149. (define (oned-table/for-each proc table)
  150.   (let loop ((previous table) (alist (cdr table)))
  151.     (if (not (null? alist))
  152.     (let ((entry (car alist))
  153.           (next (cdr alist)))
  154.       (let ((key (##weak-car entry)))
  155.         (if key
  156.         (begin
  157.           (proc (and (not (eq? key false-key)) key)
  158.             (##weak-cdr entry))
  159.           (loop alist next))
  160.         (begin
  161.           (set-cdr! previous next)
  162.           (loop previous next))))))))
  163.  
  164. (initialize-oned-table-package!)
  165.  
  166. (set! ##gc-finalize ; setup GC finalization for populations and 1d tables
  167.   (lambda ()
  168.     (gc-all-populations!)
  169.     (gc-oned-tables!)))
  170.